home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Tech Arsenal 1
/
Tech Arsenal (Arsenal Computer).ISO
/
tek-02
/
linectrl.zip
/
LINECTRL.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1993-01-04
|
6KB
|
270 lines
PROGRAM LineCtrl;
{$B-,D+,R-,S-,V-}
USES DOS, CRT;
CONST
Bell = #7;
TYPE
line = STRING[255];
VAR
Option : integer;
LineRead : line;
InFile : TEXT;
OutFile : TEXT;
InFileName : line;
OutFileName : line;
Version : line;
Buf1 : Array[1..16384] of Char;
Buf2 : Array[1..16384] of Char;
{
┌────────────────────────────────────────────────────┐
│ PROCEDURE Error_Message │
└────────────────────────────────────────────────────┘
}
PROCEDURE Error_Message (message : string);
BEGIN
WRITELN (Bell,message); { ding bell & write message }
HALT;
END;
{
┌────────────────────────────────────────────────────┐
│ PROCEDURE Usage │
└────────────────────────────────────────────────────┘
}
PROCEDURE Usage;
CONST
NL = #13#10;
BEGIN
WRITELN (Bell,
'A text file utility that removes consecutive blank lines exceeding a user',NL,
'definable number; default is 1 blank line at most. ',NL,
'',NL,
'USAGE: LINECTRL [infile] [outfile] {/numlines}',NL,
'',NL,
'"numlines" is the maximum number of consecutive blank lines to keep in the',NL,
'text file. 0 is acceptable (i.e., no blank lines).',NL);
Halt;
END;
{
┌────────────────────────────────────────────────────┐
│ PROCEDURE Read_Params │
└────────────────────────────────────────────────────┘
}
PROCEDURE Read_Params (VAR param_option : integer; VAR InFileNameV : line;
VAR OutFileNameV : line);
VAR
param : string;
code : integer;
BEGIN
IF (ParamCount IN [2,3]) THEN
BEGIN
InFileNameV := ParamStr(1);
OutFileNameV := ParamStr(2);
IF ParamStr(3) = '' THEN
BEGIN
param_option := 1;
EXIT;
END;
{ implied ELSE routine }
param := ParamStr(3); { check number of blank lines }
IF POS ('/',param) = 1 THEN { to keep }
BEGIN
DELETE (param,1,1);
VAL (param, param_option, code);
IF code <> 0 THEN
Error_Message ('Error -- Input invalid');
END
ELSE
Error_Message ('Error -- Illegal parameter');
END
ELSE
Usage;
END;
{
┌────────────────────────────────────────────────────┐
│ PROCEDURE OPEN_INFILE │
└────────────────────────────────────────────────────┘
}
PROCEDURE Open_InFile (InFileNameV : line; VAR InFileV : TEXT);
VAR
FileAttr : word;
BEGIN
{$I-}
ASSIGN (InFileV,InFileNameV);
IF IOresult <> 0 THEN Error_Message ('Error -- cannot assign filename');
GetFAttr (InFileV, FileAttr);
IF (FileAttr AND Directory) <> 0 THEN
Error_Message ('Error -- input file does not exist in current directory');
RESET (InFileV);
IF IOresult <> 0 THEN Error_Message ('Error -- cannot open input file');
SETTEXTBUF (InFileV, Buf1);
{$I+}
END;
{
┌────────────────────────────────────────────────────┐
│ PROCEDURE OPEN_OUTFILE │
└────────────────────────────────────────────────────┘
}
PROCEDURE Open_OutFile (OutFileNameV : line; VAR OutFileV : TEXT);
BEGIN
{$I-}
ASSIGN (OutFileV,OutFileNameV);
IF IOresult <> 0 THEN Error_Message ('Error -- cannot assign filename');
REWRITE (OutFileV);
IF IOresult <> 0 THEN Error_Message ('Error -- cannot open output file');
SETTEXTBUF (OutFileV, Buf2);
{$I+}
END;
{
┌────────────────────────────────────────────────────┐
│ PROCEDURE CLOSE_FILES │
└────────────────────────────────────────────────────┘
}
PROCEDURE Close_Files (VAR InFileV : TEXT; VAR OutFileV : TEXT);
BEGIN
CLOSE (InFileV);
CLOSE (OutFileV);
WRITELN (Bell); { ding bell }
END;
{
┌────────────────────────────────────────────────────┐
│ FUNCTION ALLSPACES │
└────────────────────────────────────────────────────┘
}
FUNCTION Allspaces (str : LINE) : INTEGER;
VAR
i, cnt : INTEGER;
BEGIN
i := 1;
cnt := LENGTH(str);
IF cnt = 0 THEN
Allspaces := 0
ELSE
BEGIN
WHILE (str[i] = ' ') AND (i <= cnt) DO
INC(i);
IF (i - 1) = cnt THEN
Allspaces := 1
ELSE
Allspaces := -1;
END;
END;
{
┌────────────────────────────────────────────────────┐
│ FUNCTION I_lesser │
└────────────────────────────────────────────────────┘
}
FUNCTION I_lesser (a,b : LONGINT) : LONGINT;
BEGIN
IF a < b THEN
I_lesser := a
ELSE
I_lesser := b;
END;
{
┌────────────────────────────────────────────────────┐
│ PROCEDURE PROCESS_INFILE │
└────────────────────────────────────────────────────┘
}
PROCEDURE Process_InFile (NumLines : integer;
VAR InFileV : TEXT; VAR OutFileV : TEXT);
VAR
Count : integer;
i : longint;
BEGIN
Count := 0;
WHILE NOT EOF (InFileV) DO
BEGIN
READLN (InFileV,LineRead);
CASE ALLSPACES (LineRead) OF
-1: BEGIN
IF Count > 0 THEN
BEGIN
FOR i:= 1 TO I_Lesser (Count, NumLines) DO
WRITELN (OutFile);
Count := 0;
END;
WRITELN (OutFileV, LineRead);
END;
0,1: INC (Count);
END; {case}
END; { while#1 }
FLUSH (OutFileV); { ensure all lines written }
END;
{
┌────────────────────────────────────────────────────┐
│ MAIN PROGRAM │
└────────────────────────────────────────────────────┘
}
BEGIN
Version := 'Version 1.1, 6-29-88 -- Public Domain by John Land';
CLRSCR;
Read_Params (Option, InFileName, OutFileName);
Open_InFile (InFileName, InFile);
Open_OutFile (OutFileName, OutFile);
WRITELN ('PROCESSING ',InFileName, ' INTO ', OutFileName);
Process_InFile (Option, InFile, OutFile);
Close_Files (InFile, OutFile);
END.